home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / lib / perl5 / Test / Mouse.pm < prev   
Encoding:
Perl POD Document  |  2010-03-12  |  2.5 KB  |  135 lines

  1. package Test::Mouse;
  2.  
  3. use Mouse::Exporter;
  4. use Mouse::Util qw(does_role find_meta);
  5.  
  6. use Test::Builder;
  7.  
  8. Mouse::Exporter->setup_import_methods(
  9.     as_is => [qw(
  10.         meta_ok
  11.         does_ok
  12.         has_attribute_ok
  13.         with_immutable
  14.     )],
  15. );
  16.  
  17. ## the test builder instance ...
  18.  
  19. my $Test = Test::Builder->new;
  20.  
  21. ## exported functions
  22.  
  23. sub meta_ok ($;$) { ## no critic
  24.     my ($class_or_obj, $message) = @_;
  25.  
  26.     $message ||= "The object has a meta";
  27.  
  28.     if (find_meta($class_or_obj)) {
  29.         return $Test->ok(1, $message)
  30.     }
  31.     else {
  32.         return $Test->ok(0, $message);
  33.     }
  34. }
  35.  
  36. sub does_ok ($$;$) { ## no critic
  37.     my ($class_or_obj, $does, $message) = @_;
  38.  
  39.     $message ||= "The object does $does";
  40.  
  41.     if (does_role($class_or_obj, $does)) {
  42.         return $Test->ok(1, $message)
  43.     }
  44.     else {
  45.         return $Test->ok(0, $message);
  46.     }
  47. }
  48.  
  49. sub has_attribute_ok ($$;$) { ## no critic
  50.     my ($class_or_obj, $attr_name, $message) = @_;
  51.  
  52.     $message ||= "The object does has an attribute named $attr_name";
  53.  
  54.     my $meta = find_meta($class_or_obj);
  55.  
  56.     if ($meta->find_attribute_by_name($attr_name)) {
  57.         return $Test->ok(1, $message)
  58.     }
  59.     else {
  60.         return $Test->ok(0, $message);
  61.     }
  62. }
  63.  
  64. sub with_immutable (&@) { ## no critic
  65.     my $block = shift;
  66.  
  67.     my $before = $Test->current_test;
  68.  
  69.     $block->();
  70.     $_->meta->make_immutable for @_;
  71.     $block->();
  72.  
  73.     my $num_tests = $Test->current_test - $before;
  74.  
  75.     return !grep{ !$_ } ($Test->summary)[-$num_tests .. -1];
  76. }
  77.  
  78. 1;
  79. __END__
  80.  
  81. =head1 NAME
  82.  
  83. Test::Mouse - Test functions for Mouse specific features
  84.  
  85. =head1 SYNOPSIS
  86.  
  87.   use Test::More plan => 1;
  88.   use Test::Mouse;
  89.  
  90.   meta_ok($class_or_obj, "... Foo has a ->meta");
  91.   does_ok($class_or_obj, $role, "... Foo does the Baz role");
  92.   has_attribute_ok($class_or_obj, $attr_name, "... Foo has the 'bar' attribute");
  93.  
  94. =head1 DESCRIPTION
  95.  
  96. This module provides some useful test functions for Mouse based classes. It
  97. is an experimental first release, so comments and suggestions are very welcome.
  98.  
  99. =head1 EXPORTED FUNCTIONS
  100.  
  101. =over 4
  102.  
  103. =item B<meta_ok ($class_or_object)>
  104.  
  105. Tests if a class or object has a metaclass.
  106.  
  107. =item B<does_ok ($class_or_object, $role, ?$message)>
  108.  
  109. Tests if a class or object does a certain role, similar to what C<isa_ok>
  110. does for the C<isa> method.
  111.  
  112. =item B<has_attribute_ok($class_or_object, $attr_name, ?$message)>
  113.  
  114. Tests if a class or object has a certain attribute, similar to what C<can_ok>
  115. does for the methods.
  116.  
  117. =back
  118.  
  119. =head1 SEE ALSO
  120.  
  121. =over 4
  122.  
  123. =item L<Test::More>
  124.  
  125. =back
  126.  
  127. =head1 SEE ALSO
  128.  
  129. L<Mouse>
  130.  
  131. L<Test::Moose>
  132.  
  133. =cut
  134.  
  135.